home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / buttons.lisp < prev    next >
Text File  |  1992-06-08  |  57KB  |  1,527 lines
  1. ;; -*- MODE:LISP; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package "CLIO-OPEN")
  23.  
  24. (proclaim '(special *default-display-text-font*)) ;; defined in display-text.lisp
  25.  
  26. (EXPORT '(
  27.       action-button
  28.       button-font
  29.       button-label
  30.       button-label-alignment
  31.       button-switch
  32.       choice-item-highlight-default-p
  33.       choice-item-font
  34.       choice-item-highlight-selected-p
  35.       choice-item-label
  36.       choice-item-selected-p
  37.       make-action-button
  38.       make-action-item
  39.       make-toggle-button
  40.       action-item
  41.       toggle-button
  42.       )
  43.     'clio-open)
  44.  
  45. ;;; =================================================================================== ;;;
  46. ;;;                                            ;;;
  47. ;;;     C o n s t a n t s   a n d   S t r u c t u r e s   f o r   B u t t o n s    ;;;
  48. ;;;                                            ;;;
  49. ;;; =================================================================================== ;;;
  50.  
  51. (DEFUN create-filled-in-circle-image (circle-image)
  52.  
  53.   (LET ((width (image-width circle-image))
  54.     (height (image-height circle-image))
  55.     (circle-pixarray (image-z-pixarray circle-image))
  56.     filled-in-pixarray next-pixel)
  57.  
  58.     (SETF filled-in-pixarray (make-array `(,height ,width) :element-type 'bit))
  59.  
  60.     (DO ((row 0 (1+ row)) first-1-pixel last-1-pixel)
  61.     ((= row height))
  62.  
  63.       ;;  Copy pixels upto the first 1-pixel found scanning from the left...
  64.       (DO ((col 0 (1+ col)))
  65.       ((= col width)            ; If no 1-pixels found, claim one was
  66.        (SETF first-1-pixel col))        ;   found off right-edge of array.
  67.     (SETF next-pixel (AREF circle-pixarray row col))
  68.     (SETF (AREF filled-in-pixarray row col) next-pixel)
  69.     (WHEN (= next-pixel 1)
  70.       (SETF first-1-pixel col)
  71.       (RETURN)))
  72.  
  73.       ;;  Copy pixels upto the first 1-pixel found scanning from the right...
  74.       (DO ((col (1- width) (1- col)))
  75.       ((<= col first-1-pixel)        ; If no 1-pixels found, use the one
  76.        (SETF last-1-pixel col))        ;   found in left-to-right scan.
  77.     (SETF next-pixel (AREF circle-pixarray row col))
  78.     (SETF (AREF filled-in-pixarray row col) next-pixel)
  79.     (WHEN (= next-pixel 1)
  80.       (SETF last-1-pixel col)
  81.       (RETURN)))
  82.  
  83.       ;;  Fill in the pixels between these two 1-pixels...
  84.       (DO ((col (1+ first-1-pixel) (1+ col)))
  85.       ((>= col last-1-pixel))
  86.     (SETF (AREF filled-in-pixarray row col) 1)))
  87.  
  88.     (create-image :width width
  89.           :height height
  90.           :data filled-in-pixarray)))
  91.  
  92.  
  93. (DEFSTRUCT (button-descriptor (:conc-name "") (:type vector))
  94.   ab-button-ends-image
  95.   ab-clearing-stencil-image
  96.   ab-default-ring-image
  97.   ab-body-clearing-stencil-image
  98.   ab-horizontal-menu-mark-image
  99.   ab-vertical-menu-mark-image
  100.   ab-height
  101.   ab-default-ring-height
  102.   ab-left-button-end-width
  103.   ab-right-button-end-width
  104.   ab-text-baseline                ; from top of button.
  105.   tb-min-right-margin
  106.   ab-menu-mark-bottom-rel-to-baseline        ; this includes -1 to compensate for height of
  107.                         ;    menu mark.
  108.   ab-clearing-stencil-array            ; pointer to pixarray of clearing-stencil-image.
  109.   ai-default-ring-image
  110.   ai-body-clearing-stencil-image
  111.   ai-height
  112.   ai-default-ring-height
  113.   ai-button-end-width
  114.   ai-text-baseline
  115.   )
  116.  
  117. ;;;
  118. ;;;   A structure of this type is the value fo the :OL-button-pixmaps property of the display
  119. ;;;   plist.  It is created (if it doesn't already exist for the display) and accessed by the
  120. ;;;   function get-button-pixmaps.
  121. ;;;
  122. (DEFSTRUCT (button-pixmaps (:conc-name ""))
  123.   ab-button-ends-pixmap
  124.   ab-clearing-stencil-pixmap
  125.   ab-default-ring-pixmap
  126.   ab-body-clearing-stencil-pixmap
  127.   ai-default-ring-pixmap
  128.   ai-body-clearing-stencil-pixmap
  129.   horizontal-menu-mark-pixmap
  130.   vertical-menu-mark-pixmap
  131.   )
  132.  
  133. (DEFPARAMETER *button-dimensions-by-scale*
  134.   `(:small
  135.        ,(make-button-descriptor
  136.          :ab-button-ends-image        small-action-button-ends
  137.          :ab-clearing-stencil-image        (create-filled-in-circle-image
  138.                            small-action-button-ends)
  139.          :ab-default-ring-image        small-action-button-default-ring
  140.          :ab-body-clearing-stencil-image    (create-filled-in-circle-image
  141.                            small-action-button-default-ring)
  142.          :ab-height                18
  143.          :ab-default-ring-height        13
  144.          :ab-left-button-end-width        8
  145.          :ab-right-button-end-width        9
  146.          :ab-text-baseline            11
  147.          :tb-min-right-margin        7
  148.          :ab-horizontal-menu-mark-image    small-horizontal-menu-mark
  149.          :ab-vertical-menu-mark-image    small-vertical-menu-mark
  150.          :ab-menu-mark-bottom-rel-to-baseline -1
  151.          :ai-default-ring-image        small-action-item-default-ring
  152.          :ai-body-clearing-stencil-image    (create-filled-in-circle-image
  153.                            small-action-item-default-ring)
  154.          :ai-height                17
  155.          :ai-default-ring-height        16
  156.          :ai-button-end-width        8
  157.          :ai-text-baseline            10
  158.          )
  159.     :medium
  160.        ,(make-button-descriptor
  161.          :ab-button-ends-image        medium-action-button-ends
  162.          :ab-clearing-stencil-image        (create-filled-in-circle-image
  163.                            medium-action-button-ends)
  164.          :ab-default-ring-image        medium-action-button-default-ring
  165.          :ab-body-clearing-stencil-image    (create-filled-in-circle-image
  166.                            medium-action-button-default-ring)
  167.          :ab-height                20
  168.          :ab-default-ring-height        15
  169.          :ab-left-button-end-width        9
  170.          :ab-right-button-end-width        10
  171.          :ab-text-baseline            12
  172.          :tb-min-right-margin        8
  173.          :ab-horizontal-menu-mark-image    medium-horizontal-menu-mark
  174.          :ab-vertical-menu-mark-image    medium-vertical-menu-mark
  175.          :ab-menu-mark-bottom-rel-to-baseline -1
  176.          :ai-default-ring-image        medium-action-item-default-ring
  177.          :ai-body-clearing-stencil-image    (create-filled-in-circle-image
  178.                            medium-action-item-default-ring)
  179.          :ai-height                19
  180.          :ai-default-ring-height        18
  181.          :ai-button-end-width        9
  182.          :ai-text-baseline            13
  183.          )
  184.     :large
  185.        ,(make-button-descriptor
  186.          :ab-button-ends-image        large-action-button-ends
  187.          :ab-clearing-stencil-image        (create-filled-in-circle-image
  188.                            large-action-button-ends)
  189.          :ab-default-ring-image        large-action-button-default-ring
  190.          :ab-body-clearing-stencil-image    (create-filled-in-circle-image
  191.                            large-action-button-default-ring)
  192.          :ab-height                22
  193.          :ab-default-ring-height        17
  194.          :ab-left-button-end-width        11
  195.          :ab-right-button-end-width        12
  196.          :ab-text-baseline            14
  197.          :tb-min-right-margin        10
  198.          :ab-horizontal-menu-mark-image    large-horizontal-menu-mark
  199.          :ab-vertical-menu-mark-image    large-vertical-menu-mark
  200.          :ab-menu-mark-bottom-rel-to-baseline -2
  201.          :ai-default-ring-image        large-action-item-default-ring
  202.          :ai-body-clearing-stencil-image    (create-filled-in-circle-image
  203.                            large-action-item-default-ring)
  204.          :ai-height                21
  205.          :ai-default-ring-height        20
  206.          :ai-button-end-width        10
  207.          :ai-text-baseline            13
  208.          )
  209.     :extra-large
  210.        ,(make-button-descriptor
  211.          :ab-button-ends-image        extra-large-action-button-ends
  212.          :ab-clearing-stencil-image        (create-filled-in-circle-image
  213.                            extra-large-action-button-ends)
  214.          :ab-default-ring-image        extra-large-action-button-default-ring
  215.          :ab-body-clearing-stencil-image    (create-filled-in-circle-image
  216.                            extra-large-action-button-default-ring)
  217.          :ab-height                28
  218.          :ab-default-ring-height        23
  219.          :ab-left-button-end-width        13
  220.          :ab-right-button-end-width        14
  221.          :ab-text-baseline            18
  222.          :tb-min-right-margin        12
  223.          :ab-horizontal-menu-mark-image    extra-large-horizontal-menu-mark
  224.          :ab-vertical-menu-mark-image    extra-large-vertical-menu-mark
  225.          :ab-menu-mark-bottom-rel-to-baseline -2
  226.          :ai-default-ring-image        extra-large-action-item-default-ring
  227.          :ai-body-clearing-stencil-image    (create-filled-in-circle-image
  228.                            extra-large-action-item-default-ring)
  229.          :ai-height                25
  230.          :ai-default-ring-height        23
  231.          :ai-button-end-width        14
  232.          :ai-text-baseline            16
  233.          )))
  234.  
  235. ;;;
  236. ;;;   Set the clear-stencil-array slot of each button-descriptor...
  237. ;;;
  238. (EVAL-WHEN (LOAD eval)
  239.   (DOLIST (button-dims *button-dimensions-by-scale*)
  240.     (UNLESS (SYMBOLP button-dims)        ; skip the property names...
  241.       (SETF (ab-clearing-stencil-array button-dims)
  242.         (image-z-pixarray (ab-clearing-stencil-image button-dims))))))
  243.  
  244.  
  245. ;;;----------------------------------------------------------------------------+
  246. ;;;                                                                            |
  247. ;;;                                 Label-String                               |
  248. ;;;                                                                            |
  249. ;;;----------------------------------------------------------------------------+
  250.  
  251. (deftype label-string () 'string)
  252.  
  253. (defmethod convert (contact value (type (eql 'label-string)))
  254.   (declare (ignore contact))
  255.   (when (or (symbolp value) (stringp value))
  256.     (stringable-label value)))
  257.  
  258.  
  259.  
  260. ;;;----------------------------------------------------------------------------+
  261. ;;;                                                                            |
  262. ;;;                                  Button                                    |
  263. ;;;                                                                            |
  264. ;;;----------------------------------------------------------------------------+
  265.  
  266.  
  267. (defcontact button (core contact)
  268.  
  269.   ((font     :type         fontable
  270.          :reader         button-font                   ; setf defined below
  271.         :initarg    :font
  272.          :initform     *default-display-text-font*)
  273.    
  274.    (label     :type         (or pixmap label-string)
  275.           :reader       button-label                   ; setf defined below
  276.         :initarg    :label
  277.           :initform     "")
  278.  
  279.    (label-alignment
  280.              :type        (member :left :center :right)
  281.         :accessor    button-label-alignment
  282.         :initarg    :label-alignment
  283.         :initform    :left)
  284.  
  285.    (compress-exposures
  286.                 :initform       :off
  287.         :type           (member :off :on)        
  288.         :reader         contact-compress-exposures
  289.         :allocation     :class)
  290.  
  291.    (fill-color     :type        pixel)
  292.  
  293.    (highlight-default-p
  294.                 :type            boolean
  295.              :initform    nil
  296.         :reader       choice-item-highlight-default-p)       ; setf defined below
  297.  
  298.    ;; Selected slot values:
  299.    ;;     1:   unselected
  300.    ;;     2:   selected,
  301.    ;;     -n:  select has been pressed, receipt of a release select event
  302.    ;;          will complement the selected state
  303.    (selected    :type        integer
  304.         :initform    1)
  305.  
  306.    (last-displayed-as
  307.              :type        (member :highlighted :unhighlighted)
  308.         :initform    :unhighlighted)
  309.  
  310.    (preferred-width
  311.              :type        (or null integer)
  312.                :initform    nil))
  313.  
  314.   (:resources
  315.     label
  316.     label-alignment
  317.     font))
  318.  
  319.  
  320. (DEFGENERIC display-button-highlighted (button &optional x))
  321. (DEFGENERIC display-button-unhighlighted (button &optional x))
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328. ;;;----------------------------------------------------------------------------+
  329. ;;;                                                                            |
  330. ;;;                             Accessors                                      |
  331. ;;;                                                                            |
  332. ;;;----------------------------------------------------------------------------+
  333.  
  334.  
  335.  
  336. (DEFMETHOD (SETF button-label) (new-label (button button))
  337.   (DECLARE (VALUES (OR pixmap string)))
  338.   (with-slots (label parent preferred-width width height border-width) button
  339.  
  340.     (let ((converted-label (convert button new-label '(or pixmap label-string))))
  341.       (assert converted-label
  342.           () "Label ~s is not a stringable, pixmap, or image." new-label)
  343.       (setf label converted-label))
  344.     (SETF preferred-width NIL)    ;Note - This forces recalculation of preferred values.
  345.  
  346.     (if (= 0 width)
  347.     ;; The *first* time we must initialize geometry
  348.     (multiple-value-setq (width height)
  349.       (preferred-size button))
  350.     ;; Otherwise we change-geometry to reflect new size
  351.     (when (realized-p button)
  352.       ;; We defer the change-geometry if button not realized since
  353.       ;; change-layout will be called when it is realized.
  354.       (multiple-value-bind (new-width new-height)
  355.           (preferred-size button)
  356.         ;; We don't invoke change-geometry unless size actually changed.
  357.         (unless    
  358.           (and (= width new-width) (= height new-height))
  359.           (change-geometry button :width new-width :height new-height :accept-p t)))))
  360.     label))
  361.  
  362.  
  363. (defmethod (setf button-font) (new-font (button button))
  364.   (declare (values font))
  365.   (check-type new-font fontable) 
  366.   (with-slots (font label) button
  367.     (setf font (find-font button new-font))
  368.     
  369.     ;; Save original fontname requested. Used again when changing scale.
  370.     (setf (getf (window-plist button) 'fontname) new-font)
  371.     
  372.     (when label
  373.       (setf (button-label button) label)))
  374.   new-font)
  375.  
  376.  
  377. (defmethod (setf button-label-alignment) :before (new-alignment (button button))
  378.   (check-type new-alignment (member :left :center :right) "(MEMBER :LEFT :CENTER :RIGHT)"))
  379.  
  380.  
  381.  
  382. ;;;----------------------------------------------------------------------------+
  383. ;;;                                                                            |
  384. ;;;                              Initialization                                |
  385. ;;;                                                                            |
  386. ;;;----------------------------------------------------------------------------+
  387.  
  388. (defmethod initialize-instance :after ((button button) &key &allow-other-keys)
  389.   (with-slots (label font name fill-color border-width) button
  390.    
  391.     ;;  Initialize font for current scale
  392.     (setf (button-font button) font)
  393.     
  394.     (UNLESS (resource button :name)
  395.       (SETF name (stringable-keyword label)))
  396.  
  397.     ;; Initialize fill color
  398.     (setf fill-color (contact-current-background-pixel button))
  399.  
  400.     (SETF border-width 0)
  401.  
  402.     (MULTIPLE-VALUE-BIND (p-w p-h p-b-w)
  403.     (preferred-size button)
  404.       (change-geometry button :height p-h :width p-w :border-width p-b-w :accept-p t))))
  405.  
  406.  
  407. (defmethod rescale :before ((self button))
  408.   ;; Find font for new scale, using original fontname requested.
  409.   (setf (button-font self) (getf (window-plist self) 'fontname)))
  410.  
  411.  
  412. ;;; =================================================================================== ;;;
  413. ;;;                                            ;;;
  414. ;;;             C h o i c e   P r o t o c o l   M e t h o d s            ;;;
  415. ;;;                                            ;;;
  416. ;;; =================================================================================== ;;;
  417.  
  418. (defmethod (setf choice-item-highlight-default-p) (new-value (button button))
  419.   (declare (values new-highlight-default-p-value))
  420.   (with-slots (highlight-default-p) button
  421.     (let ((new-value (when new-value t)))
  422.       (unless (eq new-value highlight-default-p)
  423.     (setf highlight-default-p new-value)
  424.     (redisplay-button button))))
  425.   new-value)
  426.  
  427. (DEFMETHOD choice-item-font ((button button))
  428.   (button-font button))
  429.  
  430.  
  431. (DEFMETHOD (SETF choice-item-font) (new-value (button button))
  432.   (SETF (button-font button) new-value))
  433.  
  434.  
  435. (DEFMETHOD choice-item-label ((button button))
  436.   (button-label button))
  437.  
  438.  
  439. (defmethod choice-item-highlight-selected-p ((button button))
  440.   (declare (values highlight-selected-p))
  441.   (with-slots (last-displayed-as) button
  442.     (eq last-displayed-as :highlighted)))
  443.  
  444.  
  445. (defmethod (setf choice-item-highlight-selected-p) (new-value (button button))
  446.   (declare (values highlight-selected-p))
  447.   (let ((highlight-selected-p (choice-item-highlight-selected-p button))
  448.     (new-value            (when new-value t)))
  449.     (unless (eq highlight-selected-p new-value)
  450.       (if new-value
  451.       (display-button-highlighted button)
  452.       (display-button-unhighlighted button))))
  453.   new-value)
  454.  
  455.  
  456. (defmethod choice-item-selected-p ((button button))
  457.   (with-slots (selected) button
  458.     (= (abs selected) 2)))
  459.  
  460.  
  461. (defmethod (setf choice-item-selected-p) (new-value (button button))
  462.   (declare (values new-value))
  463.   (let ((new-value (when new-value t)))
  464.     (unless (eq new-value (choice-item-selected-p button))
  465.       (with-slots (selected) button 
  466.     (setf selected (if new-value 2 1))
  467.     (setf (choice-item-highlight-selected-p button) new-value)
  468.     (apply-callback button (if new-value :on :off)))))
  469.   new-value)
  470.  
  471.  
  472.  
  473.  
  474.  
  475. ;;; =================================================================================== ;;;
  476. ;;;                                            ;;;
  477. ;;;       U t i l i t y   F u n c t i o n s    F o r   A l l   B u t t o n s        ;;;
  478. ;;;                                            ;;;
  479. ;;; =================================================================================== ;;;
  480.  
  481. (DEFEVENT button
  482.       (:button-press :button-1)
  483.         press-select)
  484.  
  485. (DEFEVENT button
  486.       (:button-release :button-1)
  487.         release-select)
  488.  
  489. (DEFMETHOD redisplay-button ((button button) &optional completely-p)
  490.   (with-slots (last-displayed-as) button
  491.     (CASE last-displayed-as
  492.       (:unhighlighted (display-button-unhighlighted button completely-p))
  493.       (:highlighted   (display-button-highlighted   button completely-p)))))
  494.  
  495.  
  496. (DEFMETHOD display ((button button) &optional at-x at-y at-width at-height &key)
  497.   (DECLARE (IGNORE at-x at-y at-width at-height))
  498.   (WHEN (realized-p button)
  499.     ;;  Put self on the display afresh, completely redrawing everything...
  500.     (redisplay-button button t)))
  501.  
  502.  
  503. ;;;
  504. ;;;   This function is used when a menu button must display the label of its menu's default
  505. ;;;   choice, which may not fit within the menu button.  It has more general usage than this,
  506. ;;;   should be moved to utilities.lisp.
  507. ;;;
  508.  
  509.  
  510.  
  511. (DEFUN get-button-pixmaps (button)
  512.   
  513.   ;;
  514.   ;;  Look on the display's plist for an :OL-button-pixmaps property.  If any action
  515.   ;;  button has created pixmaps from its images, they'll be here...
  516.   ;;
  517.   (LET* ((scale (contact-scale button))
  518.      (display (contact-display button))
  519.      (button-pixmaps (GETF (display-plist display) :OL-button-pixmaps))
  520.      (button-pixmaps-for-this-size-button (GETF button-pixmaps scale))
  521.      (dims (GETF *button-dimensions-by-scale* scale)))
  522.     
  523.     ;;
  524.     ;;  If there are no pixmaps cached on the display's plist for this scale action button,
  525.     ;;  create some, put them into a button-pixmaps structure, then put it on the display's plist...
  526.     ;;
  527.     (UNLESS button-pixmaps-for-this-size-button
  528.       (SETF button-pixmaps-for-this-size-button
  529.         (SETF (GETF button-pixmaps scale)
  530.           (make-button-pixmaps
  531.             :ab-button-ends-pixmap
  532.             (image-pixmap button (ab-button-ends-image dims))
  533.             :ab-clearing-stencil-pixmap
  534.             (image-pixmap button (ab-clearing-stencil-image dims))
  535.             :ab-default-ring-pixmap
  536.             (image-pixmap button (ab-default-ring-image dims))
  537.             :ab-body-clearing-stencil-pixmap
  538.             (image-pixmap button (ab-body-clearing-stencil-image dims))
  539.             :ai-default-ring-pixmap
  540.             (image-pixmap button (ai-default-ring-image dims))
  541.             :ai-body-clearing-stencil-pixmap
  542.             (image-pixmap button (ai-body-clearing-stencil-image dims))
  543.             :horizontal-menu-mark-pixmap
  544.             (image-pixmap button (ab-horizontal-menu-mark-image dims))
  545.             :vertical-menu-mark-pixmap
  546.             (image-pixmap button (ab-vertical-menu-mark-image dims)))))
  547.       (SETF (GETF (display-plist display) :OL-button-pixmaps) button-pixmaps))
  548.     
  549.     ;;
  550.     ;;  Return the button-pixmaps structure containing the pixmaps for this button's scale...
  551.     ;;
  552.     button-pixmaps-for-this-size-button))
  553.  
  554.  
  555. ;;;----------------------------------------------------------------------------+
  556. ;;;                                                                            |
  557. ;;;                           Toggle Button                                    |
  558. ;;;                                                                            |
  559. ;;;----------------------------------------------------------------------------+
  560.  
  561.  
  562.  
  563. (defcontact toggle-button (button)
  564.   ((pointer-pressed   :type      boolean
  565.               :initform  nil))
  566.   (:resources
  567.     (border-width :initform 0)
  568.     
  569.     (switch       :type (member :on :off)
  570.           :initform :off)))
  571.  
  572. (defmethod toggle-button-release-menu ((self toggle-button))
  573.   (declare (type toggle-button self))
  574.   (with-slots (pointer-pressed)
  575.     self
  576.     (when pointer-pressed
  577.       (choice-item-release self)
  578.       (setq pointer-pressed nil))))
  579.  
  580. (defmethod toggle-button-leave-with-menu-pressed ((self toggle-button))
  581.   (declare (type toggle-button self))
  582.   (with-slots (pointer-pressed)
  583.     self
  584.     (with-event (mode)
  585.       (when (and pointer-pressed
  586.          (eq mode :normal))
  587.     (choice-item-leave self)
  588.     (setq pointer-pressed nil)))))
  589.  
  590. (DEFMETHOD toggle-button-enter-with-menu-pressed ((self toggle-button))
  591.    (with-event (x y state)
  592.      (when (and (inside-contact-p self x y)
  593.         (NOT (ZEROP (LOGAND #.(make-state-mask :button-3) state))))
  594.        ;; The pointer has been dragged over this button w/menu button
  595.        ;; pressed. This has the same side effects as pressing the
  596.        ;; select button so we go ahead and use the press procedure
  597.        ;; to take care of visuals and approve the transition.
  598.        (when (choice-item-press self)
  599.      ;; Transition was approved and button is now highlighted.
  600.      ;; We set a flag so :button-release and :leave-notify events
  601.      ;; will be handled.
  602.      (with-slots (pointer-pressed) self
  603.        (setq pointer-pressed t))))))
  604.  
  605.  
  606. (DEFEVENT toggle-button
  607.       :enter-notify
  608.    toggle-button-enter-with-menu-pressed)
  609.  
  610. (defevent toggle-button
  611.       :leave-notify
  612.    toggle-button-leave-with-menu-pressed)
  613.  
  614. (defevent toggle-button
  615.       (:button-release :button-1)
  616.    tb-maybe-release-select)
  617.  
  618. ;;  These two translations are for Open Look menus, which allow item selection
  619. ;;  on both button-1 and button-3 presses.
  620. (DEFEVENT toggle-button
  621.       (:button-press :button-3)
  622.    press-select)
  623.  
  624. (DEFEVENT toggle-button
  625.       (:button-release :button-3)
  626.    toggle-button-release-menu)
  627.  
  628. (defmethod tb-maybe-release-select ((button toggle-button))
  629.   (with-slots (pointer-pressed) 
  630.     button                ;(the toggle-button button)
  631.     (when pointer-pressed
  632.       (release-select button))))
  633.  
  634.  
  635. (defun make-toggle-button (&rest initargs)
  636.   (apply #'make-contact 'toggle-button initargs))
  637.  
  638.  
  639.  
  640.  
  641. (defmethod initialize-instance :after ((toggle-button toggle-button)
  642.                        &key switch &allow-other-keys)
  643.   (with-slots (selected) toggle-button
  644.  
  645.     (when (eq switch :on)
  646.     (setf selected 2)
  647.       (display-button-highlighted toggle-button))))
  648.  
  649.  
  650. ;;; ========================================================================== ;;;
  651. ;;;                                           ;;;
  652. ;;;        ( T o g g l e )   B u t t o n   P r o t o c o l   M e t h o d s     ;;;
  653. ;;;                                           ;;;
  654. ;;; ========================================================================== ;;;
  655.  
  656. (defmethod button-switch ((toggle-button toggle-button))
  657.   (with-slots (selected) toggle-button
  658.     (if (= 1 (abs selected)) :off :on)))
  659.  
  660. (DEFMETHOD (SETF button-switch) (new-state (toggle-button toggle-button))
  661.   (ASSERT (member new-state '( :on :off)) nil
  662.       "~a is an illegal button state.  Must be :ON or :OFF." new-state)
  663.   (LET ((current-state (button-switch toggle-button)))
  664.     (WHEN (NOT (EQ current-state new-state))
  665.       ;; We simulate a button press and release to implement identical
  666.       ;; semantics whether done via API or via gesture.
  667.       (WHEN (choice-item-press toggle-button)
  668.     ;; When toggle press succeeded we follow it
  669.     ;; with a release.
  670.     (choice-item-release toggle-button)))
  671.     (button-switch toggle-button)))
  672.  
  673. (DEFMETHOD leave ((toggle-button toggle-button))
  674.   (with-event (state mode)
  675.     (when (eq mode :normal)
  676.       (with-slots (selected pointer-pressed) toggle-button
  677.     (WHEN (AND (< selected 0)
  678.            (NOT (ZEROP (LOGAND (make-state-mask :button-1) state))))
  679.       (choice-item-leave toggle-button)
  680.       (setq pointer-pressed nil))))))
  681.  
  682.  
  683. (DEFMETHOD preferred-size ((toggle-button toggle-button) &key width height border-width)
  684.     (declare (ignore width height border-width))
  685.  
  686.   (DECLARE (VALUES preferred-width preferred-height
  687.            preferred-border-width))
  688.  
  689.   ;;  A toggle-button must draw its border within its window so it can be dimmed if the button
  690.   ;;  becomes insensitive.  So its border-width is zero.
  691.   ;;  Its preferred height is that dictated by its scale slot.
  692.   ;;  Its preferred width is the width of its label plus the right/left margins plus the border
  693.   ;;  width.
  694.  
  695.   (with-slots (label font preferred-width) toggle-button
  696.     (LET*
  697.       ((scale (contact-scale toggle-button))
  698.        (dims (GETF *button-dimensions-by-scale* scale))
  699.        p-width)
  700.  
  701.       ;;  Since an Action Button's min-right-margin is 2 more than the interior margin a
  702.       ;;  Toggle Button should have, and since the border width of a Toggle Button is 1, we can
  703.       ;;  just use the Action Button's min-right-margin...
  704.       (SETF p-width (OR preferred-width
  705.             (SETF preferred-width
  706.                   (+ (label-width toggle-button label)
  707.                  (tb-min-right-margin dims) (tb-min-right-margin dims)))))
  708.  
  709.       ;;  Since an Action Button's height is exactly that of a Toggle Button...
  710.  
  711.       (VALUES p-width
  712.           (ab-height dims)
  713.           0))))
  714.  
  715.  
  716. ;;;----------------------------------------------------------------------------+
  717. ;;;                                                                            |
  718. ;;;                            Choice Item Protocol                            |
  719. ;;;                                                                            |
  720. ;;;----------------------------------------------------------------------------+
  721.  
  722.  
  723. (defmethod choice-item-press ((toggle-button toggle-button))
  724.   (with-slots (selected) toggle-button
  725.     (let ((to-selected-p (= selected 1)))
  726.       (when (apply-callback-else (toggle-button :change-allowed-p to-selected-p) t)
  727.     (setf selected (- selected))
  728.     (if to-selected-p
  729.         (display-button-highlighted toggle-button)
  730.         (display-button-unhighlighted toggle-button))
  731.     (apply-callback toggle-button :changing to-selected-p)
  732.     t))))
  733.  
  734. (defmethod choice-item-release ((toggle-button toggle-button))
  735.   (with-slots (selected) toggle-button
  736.     (apply-callback toggle-button (IF (= 2 (SETF selected (+ 3 selected))) :on :off))))
  737.  
  738. (DEFMETHOD choice-item-leave ((toggle-button toggle-button))
  739.   (with-slots (selected) toggle-button
  740.     (IF (= 2 (SETF selected (- selected)))
  741.     (PROGN
  742.       (display-button-highlighted toggle-button)
  743.       (apply-callback toggle-button :canceling-change NIL))
  744.     (PROGN
  745.       (display-button-unhighlighted toggle-button)
  746.       (apply-callback toggle-button :canceling-change T)))))
  747.  
  748. (DEFMETHOD press-select ((toggle-button toggle-button))
  749.    (WHEN (choice-item-press toggle-button)
  750.      (with-slots (pointer-pressed) toggle-button
  751.        (setq pointer-pressed t))))
  752.  
  753. (DEFMETHOD release-select ((toggle-button toggle-button))
  754.   (with-event (state)
  755.     (with-slots (selected pointer-pressed) toggle-button
  756.       (WHEN (> 0 selected)
  757.     (UNWIND-PROTECT 
  758.         (choice-item-release toggle-button)
  759.       (setq pointer-pressed nil))))))
  760.  
  761.  
  762. (DEFMETHOD (SETF choice-item-selected-p) (new-value (toggle-button toggle-button))
  763.   ;; Identical to (SETF button-switch) except returns boolean on/off indicator.
  764.   (DECLARE (VALUES new-value))
  765.   (EQ (SETF (button-switch toggle-button) (if new-value :on :off)) :on))
  766.  
  767.  
  768.  
  769.  
  770. ;;; =================================================================================== ;;;
  771. ;;;                                            ;;;
  772. ;;;                The Two Ways to Display a Toggle Button...                ;;;
  773. ;;;                                            ;;;
  774. ;;; =================================================================================== ;;;
  775.  
  776. (DEFmethod display-toggle-button ((toggle-button toggle-button) mode &optional completely-p)
  777.   (declare (type toggle-button toggle-button))
  778.   (with-slots (font fill-color foreground highlight-default-p width height)
  779.     toggle-button 
  780.     (WHEN (realized-p toggle-button)
  781.       (LET ((tb-foreground foreground) (tb-fill-color fill-color) (tb-font font)
  782.         (tb-width width) (tb-height height)
  783.         stroke-width two-stroke-widths four-stroke-widths
  784.         (sensitive-p (sensitive-p toggle-button)))
  785.     
  786.     (SETF stroke-width 1
  787.           two-stroke-widths (* 2 stroke-width)
  788.           four-stroke-widths (* 2 two-stroke-widths))
  789.     (using-gcontext (gc
  790.              :drawable     toggle-button
  791.              :foreground     tb-foreground
  792.              :background     tb-fill-color
  793.              :font     tb-font
  794.              :line-width    stroke-width
  795.              :fill-style    (IF sensitive-p :solid :stippled)
  796.              :stipple    (UNLESS sensitive-p
  797.                       (contact-image-mask toggle-button 50%gray :depth 1)))
  798.       
  799.             (WHEN completely-p
  800.               (clear-area toggle-button
  801.                       :x 0
  802.                       :y 0
  803.                       :width tb-width
  804.                       :height tb-height)
  805.  
  806.               ;;  Draw our rectangular OL UI border...
  807.               (DOTIMES (i stroke-width)
  808.                 (draw-rectangle toggle-button gc i i
  809.                         (- tb-width 1 i i)
  810.                         (- tb-height 1 i i)))
  811.  
  812.               (display-button-label toggle-button gc))
  813.  
  814.  
  815.             ;;  Draw/erase the highlight indicator...
  816.             (flet
  817.                 ((draw/erase-default-indicator ()
  818.                    (DOTIMES (i stroke-width)
  819.                  (draw-rectangle toggle-button gc (+ two-stroke-widths i) (+ two-stroke-widths i)
  820.                          (- tb-width four-stroke-widths 1 i i)
  821.                          (- tb-height four-stroke-widths 1 i i))))                   
  822.                  (draw/erase-highlight ()
  823.                    (DOTIMES (i stroke-width)
  824.                  (draw-rectangle toggle-button gc (+ stroke-width i) (+ stroke-width i)
  825.                          (- tb-width two-stroke-widths 1 i i)
  826.                          (- tb-height two-stroke-widths 1 i i))))
  827.                  )
  828.               #+ansi-common-lisp (declare (inline draw/erase-default-indicator draw/erase-highlight))
  829.               ;;  Draw the default indicator if necessary...
  830.               (if highlight-default-p
  831.                   (draw/erase-default-indicator)
  832.                   (with-gcontext (gc :foreground tb-fill-color :background tb-foreground)
  833.                 (draw/erase-default-indicator)))
  834.               (IF (EQ mode :unhighlighted)
  835.                   (with-gcontext (gc :foreground tb-fill-color :background tb-foreground)
  836.                 (draw/erase-highlight))
  837.                   (draw/erase-highlight)))
  838.  
  839.             )))))
  840.  
  841.  
  842. (DEFMETHOD display-button-highlighted ((toggle-button toggle-button) &optional completely-p)
  843.   (with-slots (last-displayed-as) toggle-button
  844.     (display-toggle-button toggle-button :highlighted completely-p)
  845.     (SETF last-displayed-as :highlighted)))
  846.  
  847.  
  848. (DEFMETHOD display-button-unhighlighted ((toggle-button toggle-button) &optional completely-p)
  849.   (with-slots (last-displayed-as) toggle-button
  850.     (display-toggle-button toggle-button :unhighlighted completely-p)
  851.     (SETF last-displayed-as :unhighlighted)))
  852.  
  853.  
  854.  
  855. ;;; =================================================================================== ;;;
  856. ;;;                                            ;;;
  857. ;;;          D i s p l a y   a   T o g g l e   B u t t o n ' s   L a b e l        ;;;
  858. ;;;                                            ;;;
  859. ;;; =================================================================================== ;;;
  860.  
  861. (DEFMETHOD display-button-label ((self toggle-button) gc)
  862.   (display-any-buttons-label self gc 1 -2))
  863.  
  864. (defgeneric label-width (button label)
  865.   (:documentation "Return the width of the button LABEL in pixels."))
  866.  
  867. (defmethod label-width ((button button) (label string))
  868.   (with-slots (font) button
  869.     (text-width font label)))
  870.  
  871. (defmethod label-width ((button button) (label pixmap)) 
  872.   (or (getf (pixmap-plist label) :width)
  873.       (with-state (label)
  874.     (setf (getf (pixmap-plist label) :width)  (drawable-width label)
  875.           (getf (pixmap-plist label) :height) (drawable-height label)))))
  876.  
  877. (defmethod display-any-buttons-label ((button button) gc top-border-thickness left-border-adjustment)
  878.   (with-slots (label label-alignment width height)
  879.     button ; (the button button)
  880.     (let*
  881.       ((dims        (getf *button-dimensions-by-scale* (contact-scale button)))
  882.        (label-width (label-width button label))
  883.        (margin      (- (ab-left-button-end-width dims) left-border-adjustment)) 
  884.        (left-margin (max margin
  885.              (case label-alignment
  886.                (:left   0)
  887.                (:center (pixel-round (- width label-width) 2))
  888.                (:right  (- width margin label-width)))))) 
  889.       
  890.       (if (stringp label)
  891.       (draw-glyphs
  892.         button gc
  893.         left-margin (+ top-border-thickness (ab-text-baseline dims))
  894.         label)
  895.       
  896.       ;; Else display pixmap label...
  897.       (let ((label-height (getf (pixmap-plist label) :height)))
  898.         (with-gcontext (gc :fill-style :tiled :tile label)
  899.           (draw-rectangle
  900.         button gc
  901.         left-margin (max 0 (pixel-round (- height label-height) 2))
  902.         label-width label-height t)))))))
  903.  
  904.  
  905. ;;;----------------------------------------------------------------------------+
  906. ;;;                                                                            |
  907. ;;;                           Action Button                                    |
  908. ;;;                                                                            |
  909. ;;;----------------------------------------------------------------------------+
  910.  
  911.  
  912. (defcontact action-button (button) ()
  913.   (:resources (border-width :initform 0)))
  914.  
  915. (defun make-action-button (&rest initargs)
  916.   (apply #'make-contact 'action-button initargs))
  917.  
  918. (defcontact action-item (action-button) ()
  919.   (:resources
  920.     (label-alignment :initform :left)))
  921.  
  922. (DEFUN circular-list-of-one-item (item)
  923.   "Return a circular list whose elements are ITEM (over and over again)."
  924.   (LET ((tem (LIST item)))
  925.     (RPLACD tem tem)
  926.     TEM))
  927.  
  928.  
  929. (defmethod choice-item-press ((action-button action-button))
  930.   
  931.   ;; choice-item-press does the necessary tasks to reflect
  932.   ;; an action-button press provided that the :change-allowed-p
  933.   ;; callback (if any) allows the state change.  The returned
  934.   ;; value indicates whether the press was allowed or not.
  935.   
  936.   (when (apply-callback-else (action-button :change-allowed-p t) t)
  937.     (display-button-highlighted action-button)
  938.     (apply-callback action-button :press)
  939.     (apply-callback action-button :changing t)
  940.     t))
  941.  
  942. (DEFMETHOD choice-item-release ((action-button action-button))
  943.   
  944.   ;; choice-item-release does the necessary tasks to reflect
  945.   ;; an action-button release.  It is assumed that a press has
  946.   ;; occurred and that the press action was allowed; thus, we
  947.   ;; don't invoke the :change-allowed-p callback again here.
  948.  
  949.   (with-slots (selected) action-button                 
  950.     (display-action-button-busy action-button)
  951.     (display-force-output (contact-display action-button))
  952.  
  953.     ;; Ensure highlight is cleaned up in case :release callback performs a throw.
  954.     (unwind-protect
  955.     (apply-callback action-button :release)
  956.       (SETF selected 2)
  957.       (apply-callback action-button :on)
  958.       (SETF selected 1)
  959.       (display-button-unhighlighted action-button)
  960.       (apply-callback action-button :changing NIL)
  961.       (apply-callback action-button :off))))
  962.  
  963. (DEFMETHOD choice-item-leave ((action-button action-button))
  964.   (display-button-unhighlighted action-button)
  965.   (apply-callback action-button :canceling-change T))
  966.  
  967. (DEFMETHOD press-select ((action-button action-button))
  968.   (with-event (x y)
  969.     (WHEN (inside-contact-p action-button x y)
  970.       ;;  Choice-item-press will set last-displayed-as if the
  971.       ;;  transition is allowed.
  972.       (choice-item-press action-button))))
  973.  
  974. (DEFMETHOD release-select ((action-button action-button))
  975.   (with-slots (last-displayed-as) action-button
  976.     ;;  Do nothing unless highlighted/selected already...
  977.     (WHEN (EQ last-displayed-as :highlighted)
  978.       (choice-item-release action-button))))
  979.  
  980.  
  981. (DEFMETHOD (SETF choice-item-selected-p) (new-value (action-button action-button))
  982.   (DECLARE (VALUES new-value))
  983.   (with-slots (last-displayed-as) action-button
  984.     ;; For an unselected action button and a new-value of T, this method must act like a button
  985.     ;; press followed immediately by a button release.  If the button is already
  986.     ;; selected, this method does nothing.  Note that to prevent strange behavior if the
  987.     ;; application calls us with a new-value of T from within the action-button's :release
  988.     ;; callback, we do not check the button's selected-p slot.  Instead, we check the button's
  989.     ;; last-displayed-as slot, only doing something if the button is completely inactive.
  990.     (WHEN (and new-value (EQ last-displayed-as :unhighlighted))
  991.       (WHEN (choice-item-press action-button)
  992.     ;; When press action was allowed we proceed with
  993.     ;; ersatz release.
  994.     (choice-item-release action-button)))
  995.     
  996.     ;; else the application is trying to unselect an action button.  This is meaningful only when
  997.     ;; the action button is selected, which is a momentary state for an action button.  A
  998.     ;; "selected" action button by definition is in the process of transitioning to "unselected".
  999.     ;; As a part of this transition all callbacks will be applied.  So in this case it seems
  1000.     ;; reasonable for the method to do nothing
  1001.     
  1002.     new-value))
  1003.  
  1004.  
  1005. (DEFMETHOD leave ((action-button action-button))
  1006.   (with-event (state mode)
  1007.     (when (eq mode :normal)
  1008.       (with-slots (last-displayed-as) action-button
  1009.     (WHEN (AND (EQ last-displayed-as :highlighted)
  1010.            (NOT (ZEROP (LOGAND (make-state-mask :button-1) state))))
  1011.       (choice-item-leave action-button))))))
  1012.  
  1013. (defevent action-button
  1014.       :leave-notify
  1015.    leave)
  1016.  
  1017.  
  1018.  
  1019. ;;;
  1020. ;;;    The three basic ways to display an action button...
  1021. ;;;
  1022.  
  1023. (DEFMETHOD redisplay-button ((action-button action-button) &optional completely-p)
  1024.   (with-slots (last-displayed-as) action-button
  1025.     (CASE last-displayed-as
  1026.       (:unhighlighted (display-button-unhighlighted action-button completely-p))
  1027.       (:highlighted   (display-button-highlighted   action-button completely-p))
  1028.       (:busy        (display-action-button-busy   action-button completely-p)))))
  1029.  
  1030. (DEFMETHOD display-button-unhighlighted ((action-button action-button) &optional completely-p)
  1031.   (with-slots (font fill-color foreground highlight-default-p last-displayed-as) action-button
  1032.     
  1033.     (when (realized-p action-button)
  1034.       (LET ((ab-foreground foreground) (ab-fill-color fill-color) (ab-font font)
  1035.         (sensitive-p (sensitive-p action-button)))
  1036.     
  1037.     ;;  If displaying a dimmed (insensitive) button, always redraw the entire thing...
  1038.     (UNLESS sensitive-p
  1039.       (SETF completely-p t))
  1040.     
  1041.     (using-gcontext (gc
  1042.               :drawable     action-button
  1043.               :foreground     ab-foreground
  1044.               :background     ab-fill-color
  1045.               :font        ab-font
  1046.               :fill-style    (IF sensitive-p :solid :stippled)
  1047.               :stipple    (UNLESS sensitive-p
  1048.                       (contact-image-mask action-button 50%gray :depth 1)))
  1049.       
  1050.       (with-gcontext (gc :foreground ab-fill-color :background ab-foreground)
  1051.         (IF completely-p
  1052.         (clear-button-and-display-border action-button gc)
  1053.         (just-clear-body-of-button action-button gc)))
  1054.       
  1055.       (display-button-label action-button gc)
  1056.       
  1057.       (WHEN highlight-default-p
  1058.         (display-default-indicator action-button gc)))))
  1059.       
  1060.     (SETF last-displayed-as :unhighlighted)))
  1061.  
  1062.  
  1063. (DEFMETHOD display-button-highlighted ((action-button action-button) &optional completely-p)
  1064.  
  1065.   (with-slots (font fill-color foreground last-displayed-as) action-button
  1066.     
  1067.     (when (realized-p action-button)
  1068.       (LET ((ab-foreground foreground) (ab-fill-color fill-color) (ab-font font))
  1069.     
  1070.     ;;  An insensitive action button can never be busy, so sensitive-p is not checked
  1071.     ;;  or handled here...
  1072.     (using-gcontext (gc
  1073.               :drawable     action-button
  1074.               :foreground     ab-fill-color
  1075.               :background     ab-foreground
  1076.               :font     ab-font)
  1077.       
  1078.       (with-gcontext (gc :foreground ab-foreground :background ab-fill-color)
  1079.         (IF completely-p
  1080.         (clear-button-and-display-border action-button gc)
  1081.         (just-clear-body-of-button action-button gc)))
  1082.       
  1083.       (display-button-label action-button gc))))
  1084.     (SETF last-displayed-as :highlighted)))
  1085.  
  1086.  
  1087.  
  1088. (defmethod display-action-button-busy ((action-button action-button) &optional completely-p)  
  1089.   (with-slots (font fill-color foreground last-displayed-as) action-button
  1090.     
  1091.     (when (realized-p action-button)
  1092.       (let ((ab-foreground foreground) (ab-fill-color fill-color) (ab-font font))
  1093.     
  1094.     ;;  An insensitive action button can never be busy, so sensitive-p is not checked
  1095.     ;;  or handled here...
  1096.      
  1097.       ;;  Clear out the non-margin, non-border part of the button with the busy-pixmap
  1098.       ;;  stipple pattern...
  1099.       (using-gcontext
  1100.         (gc
  1101.           :drawable   action-button
  1102.           :foreground ab-fill-color
  1103.           :background ab-foreground
  1104.           :stipple    (contact-image-mask action-button 88%gray :depth 1)
  1105.           :fill-style :opaque-stippled)
  1106.         (if completely-p
  1107.         (clear-button-and-display-border action-button gc)
  1108.         (just-clear-body-of-button action-button gc)))
  1109.  
  1110.       ;;  Draw the text label in the foreground color...
  1111.       (using-gcontext
  1112.         (gc
  1113.           :drawable     action-button
  1114.           :foreground     ab-foreground
  1115.           :background     ab-fill-color
  1116.           :font         ab-font) 
  1117.       (display-button-label action-button gc))))
  1118.     
  1119.     (setf last-displayed-as :busy)))
  1120.  
  1121.  
  1122. (DEFMETHOD display-default-indicator ((action-button action-button) gc)
  1123.   ;;  Draws the 1-2 pixel wide default indicator in the foreground color of GC...
  1124.   (with-slots (width height) action-button
  1125.     (LET* ((scale (contact-scale action-button)) interior-width
  1126.        (dims (GETF *button-dimensions-by-scale* scale))
  1127.        (top-border-thickness (IF (TYPEP action-button 'action-item) 0 1))
  1128.        (button-pixmaps (get-button-pixmaps action-button)))
  1129.       
  1130.       (SETF interior-width
  1131.         (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims)))
  1132.  
  1133.       ;;  Draw the left-end of the default indicator...
  1134.       (with-gcontext (gc :clip-x 0 :clip-y top-border-thickness
  1135.              :clip-mask (ab-default-ring-pixmap button-pixmaps))
  1136.     (draw-rectangle action-button gc
  1137.             0 top-border-thickness
  1138.             (ab-left-button-end-width dims) height t))
  1139.  
  1140.       ;;  Draw the top horizontal line of the default indicator...
  1141.       (draw-rectangle action-button gc
  1142.               (ab-left-button-end-width dims)
  1143.               (+ top-border-thickness 1)
  1144.               interior-width 0)
  1145.  
  1146.       ;;  Draw the bttom horizontal line of the default indicator...
  1147.       (draw-rectangle action-button gc
  1148.               (ab-left-button-end-width dims)
  1149.               (+ top-border-thickness (ab-default-ring-height dims))
  1150.               interior-width 0)
  1151.  
  1152.       ;;  Draw the right-end of the default indicator...
  1153.       (with-gcontext (gc :clip-x interior-width :clip-y top-border-thickness
  1154.              :clip-mask (ab-default-ring-pixmap button-pixmaps))
  1155.     (draw-rectangle action-button gc
  1156.             (+ (ab-left-button-end-width dims) interior-width)
  1157.             top-border-thickness
  1158.             (ab-right-button-end-width dims) (contact-height action-button) t)))))
  1159.  
  1160.  
  1161. (DEFMETHOD just-clear-body-of-button ((action-button action-button) gc)
  1162.   (with-slots (width height) action-button
  1163.     (LET* ((scale (contact-scale action-button))
  1164.        interior-width body-clear-stencil
  1165.        (dims (GETF *button-dimensions-by-scale* scale))
  1166.        (top-border-thickness (IF (TYPEP action-button 'action-item) 0 1))
  1167.        (button-pixmaps (get-button-pixmaps action-button))
  1168.        (fill-style (gcontext-fill-style gc)))
  1169.  
  1170.       (SETF interior-width
  1171.         (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims)))
  1172.       
  1173.       (when (< interior-width 0)
  1174.     (setq interior-width 0))
  1175.  
  1176.       (SETF body-clear-stencil (ab-body-clearing-stencil-pixmap button-pixmaps))
  1177.  
  1178.       (with-gcontext (gc :fill-style (IF (EQ fill-style :stippled) :solid fill-style))
  1179.     
  1180.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1181.     ;;   Clear out the button's non-border, non-margin pixels to
  1182.     ;;    the foreground color of GC...
  1183.     
  1184.     ;;   Start by clearing the left end of the button...
  1185.     (with-gcontext (gc :clip-x 0 :clip-y top-border-thickness
  1186.                :clip-mask body-clear-stencil)
  1187.       (draw-rectangle action-button gc 0 top-border-thickness
  1188.               (ab-left-button-end-width dims) (contact-height action-button) t))
  1189.     
  1190.     ;;   Clear out the background for the label...
  1191.     (draw-rectangle action-button gc
  1192.             (ab-left-button-end-width dims)
  1193.             (+ top-border-thickness 1)
  1194.             interior-width (ab-default-ring-height dims) t)
  1195.     
  1196.     ;;   Clear out the drawable pixels of the right button end...
  1197.     (with-gcontext (gc :clip-x interior-width
  1198.                :clip-y top-border-thickness
  1199.                :clip-mask body-clear-stencil)
  1200.       (draw-rectangle action-button gc
  1201.               (+ (ab-left-button-end-width dims) interior-width)
  1202.               top-border-thickness
  1203.               (ab-right-button-end-width dims) height t))))))
  1204.  
  1205.  
  1206. (DEFMETHOD clear-button-and-display-border ((action-button action-button) gc)
  1207.   (with-slots (foreground fill-color width height) action-button
  1208.     (LET* ((scale (contact-scale action-button))
  1209.        (ab-fill-color fill-color) (ab-foreground foreground) interior-width
  1210.        clear-stencil border-stencil
  1211.        (dims (GETF *button-dimensions-by-scale* scale))
  1212.        (button-pixmaps (get-button-pixmaps action-button))
  1213.        (fill-style (gcontext-fill-style gc)))
  1214.  
  1215.       (SETF interior-width
  1216.         (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims)))
  1217.       
  1218.       (when (< interior-width 0)
  1219.     (setq interior-width 0))
  1220.  
  1221.       (SETF clear-stencil (ab-clearing-stencil-pixmap button-pixmaps)
  1222.         border-stencil (ab-button-ends-pixmap button-pixmaps))
  1223.       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1224.       ;;   Clear out all the button's pixels to fill-color...
  1225.       
  1226.       (with-gcontext (gc :fill-style (IF (EQ fill-style :stippled) :solid fill-style))
  1227.     
  1228.     ;;   Start by clearing the left end of the button...
  1229.     (with-gcontext (gc :clip-x 0 :clip-y 0 :clip-mask clear-stencil)
  1230.       (draw-rectangle action-button gc 0 0
  1231.               (ab-left-button-end-width dims) height t))
  1232.     ;;   Clear out the background for the label...
  1233.     (draw-rectangle action-button gc
  1234.             (ab-left-button-end-width dims) 0
  1235.             interior-width height t)
  1236.     ;;   Clear out the drawable pixels of the right button end...
  1237.     (with-gcontext (gc :clip-x interior-width :clip-y 0 :clip-mask clear-stencil)
  1238.       (draw-rectangle action-button gc
  1239.               (+ (ab-left-button-end-width dims) interior-width) 0
  1240.               (ab-right-button-end-width dims) height t)))
  1241.       
  1242.       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1243.       ;;   Draw in the button's border in foreground...
  1244.       (with-gcontext (gc :foreground ab-foreground :background ab-fill-color
  1245.              :fill-style (IF (EQ fill-style :opaque-stippled) :solid fill-style))
  1246.     
  1247.     ;;   Start by drawing the border on the left end of the button...
  1248.     (with-gcontext (gc :clip-x 0 :clip-y 0 :clip-mask border-stencil)
  1249.       (draw-rectangle action-button gc 0 0
  1250.               (ab-left-button-end-width dims)
  1251.               height t))
  1252.     
  1253.     ;;   Draw the top and bottom borders for the label...
  1254.     (draw-rectangle action-button gc
  1255.             (ab-left-button-end-width dims) 0 interior-width 0)
  1256.     
  1257.     (draw-rectangle action-button gc
  1258.             (ab-left-button-end-width dims) (- (ab-height dims) 2)
  1259.             interior-width 1)
  1260.     
  1261.     ;;   Finish by drawing the border on the right end of the button...
  1262.     (with-gcontext (gc :clip-x interior-width :clip-y 0 :clip-mask border-stencil)
  1263.       (draw-rectangle action-button gc
  1264.               (+ (ab-left-button-end-width dims) interior-width) 0
  1265.               (ab-right-button-end-width dims) height t)))
  1266.       )))
  1267.  
  1268.  
  1269. (DEFMETHOD display-button-label ((self action-button) gc)
  1270.   (display-any-buttons-label self gc 1 0))
  1271.  
  1272.  
  1273. (DEFMETHOD preferred-size ((action-button action-button) &key width height border-width)
  1274.     (declare (ignore width height border-width))
  1275.  
  1276.   (DECLARE (VALUES preferred-width preferred-height
  1277.            preferred-border-width))
  1278.  
  1279.   ;;  An action button always wants a border-width of zero.
  1280.   ;;  Its preferred height is that dictated by its scale slot.
  1281.   ;;  Given a text label, its preferred width is the width of its label in the font
  1282.   ;;    corresponding to the scale plus the widths of its button ends.
  1283.   ;;  Given an image or pixmap label, use its width.
  1284.  
  1285.   (with-slots (label font preferred-width width height) action-button
  1286.     (LET* ((scale (contact-scale action-button))
  1287.       (dims (GETF *button-dimensions-by-scale* scale))
  1288.       p-width p-height)
  1289.  
  1290.       (SETF p-width
  1291.         (OR preferred-width
  1292.         (SETF preferred-width (+ (ab-left-button-end-width dims)
  1293.                      (ab-right-button-end-width dims)
  1294.                      (label-width action-button label)))))
  1295.       
  1296.       (SETF p-height (ab-height dims))
  1297.  
  1298.       (VALUES p-width (ab-height dims) 0))))
  1299.  
  1300.  
  1301. (DEFMETHOD inside-contact-p ((action-button action-button) x y)
  1302.   "Returns T iff the point (X,Y) is within the rounded borders of ACTION-BUTTON."
  1303.   (with-slots (width height) action-button
  1304.     (LET* ((scale (contact-scale action-button))
  1305.        (dims (GETF *button-dimensions-by-scale* scale)))
  1306.       (AND (< -1 x width) (< -1 y height)
  1307.        (OR (<= (ab-left-button-end-width dims)
  1308.            x
  1309.            (- width (ab-right-button-end-width dims) 1))
  1310.            (LET* ((clearing-stencil-array (ab-clearing-stencil-array dims)))        
  1311.          (WHEN (> x (ab-left-button-end-width dims))
  1312.            (DECF x (- width (ab-left-button-end-width dims) (ab-right-button-end-width dims))))
  1313.          (NOT (ZEROP (AREF clearing-stencil-array x y)))))))))
  1314.  
  1315.  
  1316.  
  1317.  
  1318.  
  1319. ;;;----------------------------------------------------------------------------+
  1320. ;;;                                                                            |
  1321. ;;;                            Action Item                                     |
  1322. ;;;                                                                            |
  1323. ;;;----------------------------------------------------------------------------+
  1324.  
  1325. ;;; An ACTION-ITEM is a specialization of an ACTION-BUTTON and is intended for use
  1326. ;;; in OL compliant menus.  It differs from an ACTION-BUTTON in appearance as well
  1327. ;;; as in its sensitivity to various mouse gestures depending on the mode of the
  1328. ;;; menu which contains it.
  1329.  
  1330. #|| ; moved fordward in this file
  1331. (defcontact action-item (action-button) ()
  1332.   (:resources
  1333.     (label-alignment :initform :left)))
  1334. ||#
  1335.  
  1336. (defmethod action-item-release-menu ((self action-item))
  1337.   (declare (type action-item self))
  1338.   (with-slots (last-displayed-as)
  1339.     self
  1340.     (when (eq last-displayed-as :highlighted)
  1341.       (choice-item-release self))))
  1342.  
  1343. (defmethod action-item-leave-with-menu-pressed ((self action-item))
  1344.   (declare (type action-item self))
  1345.   (with-slots (last-displayed-as) self
  1346.     (with-event (mode)
  1347.       (unless (eq mode :grab)
  1348.     (when (eq last-displayed-as :highlighted)
  1349.       (choice-item-leave self))))))
  1350.  
  1351. (defmethod action-item-enter-with-menu-pressed ((self action-item))
  1352.   (with-slots (last-displayed-as) self
  1353.     (when (eq last-displayed-as :unhighlighted)
  1354.       (with-event (x y state)
  1355.     (when (and (inside-contact-p self x y)
  1356.            (not (zerop (logand #.(make-state-mask :button-3) state))))
  1357.       ;; The pointer has been dragged over this button w/menu button
  1358.       ;; pressed. This has the same side effects as pressing the
  1359.       ;; select button so we go ahead and use the press procedure
  1360.       ;; to take care of visuals and approve the transition.
  1361.       ;; The last-displayed-as slot is set inside choice-item-press
  1362.       ;; if the transition is approved.
  1363.       (choice-item-press self))))))
  1364.  
  1365. (DEFEVENT action-item
  1366.       :enter-notify
  1367.    action-item-enter-with-menu-pressed)
  1368.  
  1369. (defevent action-item
  1370.       :leave-notify
  1371.    action-item-leave-with-menu-pressed)
  1372.  
  1373. (defevent action-item
  1374.       (:button-release :button-3)
  1375.    action-item-release-menu)
  1376.  
  1377. ;;  This translation is for Open Look menus, which allow item selection
  1378. ;;  on both button-1 and button-3 presses.
  1379. (DEFEVENT action-item
  1380.       (:button-press :button-3)
  1381.    press-select)
  1382.  
  1383. (defun make-action-item (&rest initargs)
  1384.   (apply #'make-contact 'action-item initargs))
  1385.  
  1386.  
  1387. ;;;
  1388. ;;;    New drawing methods for an action-item...
  1389. ;;;
  1390.  
  1391. (DEFMETHOD inside-contact-p ((self action-item) x y)
  1392.   "Returns T iff the point (X,Y) is within an action-item."
  1393.   (with-slots (width height) self
  1394.     (AND (< -1 x width) (< -1 y height))))
  1395.  
  1396.  
  1397. (defmethod display-button-label ((self action-item) gc)
  1398.   (with-slots (label label-alignment font width height) self
  1399.     (let*
  1400.       ((label-width (label-width self label))
  1401.        (dims        (getf *button-dimensions-by-scale* (contact-scale self)))
  1402.        (left-margin (max (ai-button-end-width dims)
  1403.              (case label-alignment
  1404.                (:left   0)
  1405.                (:center (pixel-round (- width label-width) 2))
  1406.                (:right  (- width (ai-button-end-width dims) label-width)))))) 
  1407.       
  1408.       (if (stringp label)
  1409.       (draw-glyphs self gc left-margin (ai-text-baseline dims) label)
  1410.       
  1411.       ;; Else draw pixmap label...
  1412.       (let ((label-height (getf (pixmap-plist label) :height)))
  1413.         (with-gcontext (gc :fill-style :tiled :tile label)
  1414.           (draw-rectangle
  1415.         self gc
  1416.         left-margin (max 0 (pixel-round (- height label-height) 2))
  1417.         label-width label-height t)))))))
  1418.  
  1419.  
  1420. (DEFMETHOD display-default-indicator ((action-item action-item) gc)
  1421.   ;;  Draws the 1-2 pixel wide default indicator in the foreground color of GC...
  1422.   (with-slots (width height) action-item
  1423.     (LET* ((scale (contact-scale action-item)) interior-width
  1424.        (dims (GETF *button-dimensions-by-scale* scale))
  1425.        (button-pixmaps (get-button-pixmaps action-item))
  1426.        (button-end-width (ai-button-end-width dims))
  1427.        (default-ring-height (ai-default-ring-height dims)))
  1428.       
  1429.       (SETF interior-width
  1430.         (- width button-end-width button-end-width))
  1431.  
  1432.       ;;  Draw the left-end of the default indicator...
  1433.       (with-gcontext (gc :clip-x 0 :clip-y 0
  1434.              :clip-mask (ai-default-ring-pixmap button-pixmaps))
  1435.     (draw-rectangle action-item gc
  1436.             0  0
  1437.             button-end-width default-ring-height t))
  1438.  
  1439.       ;;  Draw the top horizontal line of the default indicator...
  1440.       (draw-rectangle action-item gc button-end-width 0 interior-width 0)
  1441.  
  1442.       ;;  Draw the bottom horizontal line of the default indicator...
  1443.       (draw-rectangle action-item gc button-end-width (1- default-ring-height) interior-width 0)
  1444.  
  1445.       ;;  Draw the right-end of the default indicator...
  1446.       (with-gcontext (gc :clip-x interior-width :clip-y 0
  1447.              :clip-mask (ai-default-ring-pixmap button-pixmaps))
  1448.     (draw-rectangle action-item gc
  1449.             (+ button-end-width interior-width) 0
  1450.             button-end-width default-ring-height t)))))
  1451.  
  1452.  
  1453. (DEFMETHOD just-clear-body-of-button ((action-item action-item) gc)
  1454.   (with-slots (width height) action-item
  1455.     (LET* ((scale (contact-scale action-item)) interior-width body-clear-stencil
  1456.        (dims (GETF *button-dimensions-by-scale* scale))
  1457.        (button-pixmaps (get-button-pixmaps action-item))
  1458.        (button-end-width (ai-button-end-width dims))
  1459.        (default-ring-height (ai-default-ring-height dims))
  1460.        (fill-style (gcontext-fill-style gc)))
  1461.       
  1462.       (SETF interior-width
  1463.         (- width button-end-width button-end-width))
  1464.       
  1465.       (when (< interior-width 0)
  1466.     (setq interior-width 0))
  1467.       
  1468.       (SETF body-clear-stencil (ai-body-clearing-stencil-pixmap button-pixmaps))
  1469.  
  1470.       (with-gcontext (gc :fill-style (IF (EQ fill-style :stippled) :solid fill-style))
  1471.     
  1472.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1473.     ;;   Clear out the button's non-border, non-margin pixels to
  1474.     ;;    the foreground color of GC...
  1475.     
  1476.     ;;   Start by clearing the left end of the button...
  1477.     (with-gcontext (gc :clip-x 0 :clip-y 0 :clip-mask body-clear-stencil)
  1478.       (draw-rectangle action-item gc 0 0
  1479.               button-end-width default-ring-height t))
  1480.     
  1481.     ;;   Clear out the background for the label...
  1482.     (draw-rectangle action-item gc
  1483.             button-end-width 0
  1484.             interior-width default-ring-height t)
  1485.     
  1486.     ;;   Clear out the drawable pixels of the right button end...
  1487.     (with-gcontext (gc :clip-x interior-width :clip-y 0 :clip-mask body-clear-stencil)
  1488.       (draw-rectangle action-item gc
  1489.               (+ button-end-width interior-width) 0
  1490.               button-end-width default-ring-height t))))))
  1491.  
  1492.  
  1493. (DEFMETHOD clear-button-and-display-border ((action-item action-item) gc)
  1494.   (with-slots (foreground fill-color width height) action-item
  1495.  
  1496.       (clear-area action-item)
  1497.  
  1498.       (just-clear-body-of-button action-item gc)))
  1499.  
  1500.  
  1501. (DEFMETHOD preferred-size ((action-item action-item) &key width height border-width)
  1502.     (declare (ignore width height border-width))
  1503.  
  1504.   (DECLARE (VALUES preferred-width preferred-height
  1505.            preferred-border-width))
  1506.  
  1507.   ;;  An action button always wants a border-width of zero.
  1508.   ;;  Its preferred height is that dictated by its scale slot.
  1509.   ;;  Given a text label, its preferred width is the width of its label in the font
  1510.   ;;    corresponding to the scale plus the widths of its button ends.
  1511.   ;;  Given an image or pixmap label, use its width.
  1512.  
  1513.   (with-slots (label font preferred-width width height) action-item
  1514.     (LET* ((scale (contact-scale action-item))
  1515.       (dims (GETF *button-dimensions-by-scale* scale))
  1516.       (button-end-width (ai-button-end-width dims))
  1517.       p-width)
  1518.  
  1519.       (SETF p-width
  1520.         (OR preferred-width
  1521.         (SETF preferred-width (+ button-end-width
  1522.                      (label-width action-item label)
  1523.                      button-end-width))))
  1524.  
  1525.       (VALUES p-width (ai-height dims) 0))))
  1526.  
  1527.